home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Mops 2.7 / Mops source / System source / ANSI < prev    next >
Text File  |  1993-06-15  |  3KB  |  133 lines
  1. \ ANSI shell - Sept 92.
  2.  
  3. \ Loading this file should give you an ANSI Forth system.
  4.  
  5. \ We implement the CORE word set (of course), the ERROR and ERROR EXT words,
  6. \ and most of the CORE EXT words.
  7.  
  8. \ The only CORE EXT words NOT implemented are:
  9. \  C"  CONVERT  EXPECT  MARKER  ROLL  SPAN
  10. \ Of these, CONVERT, EXPECT and SPAN are obsolete, and ROLL is inefficient
  11. \ and rather useless.
  12.  
  13. need    longMath
  14.  
  15. \ First, Mops defines a number of words as compile-only, which have to
  16. \ be EXECUTEable in ANSI.  We'll make them state-smart in the next
  17. \ Mops version.
  18.  
  19. : 1+    1 +  ;
  20. : 2+    2 +  ;
  21. : 3+    3 +  ;
  22. : 4+    4 +  ;
  23.  
  24. : 1-    1 -  ;
  25. : 2-    2 -  ;
  26. : 3-    3 -  ;
  27. : 4-    4 -  ;
  28.  
  29. : 2*    1 <<  ;
  30. : 2/    1 a>> ;
  31. : 4*    2 <<  ;
  32. : 4/    2 >>  ;
  33.  
  34.  
  35. :code 2@
  36.     move.l    (a6),a0
  37.     move.l    4(a0),(a6)
  38.     push.l    (a0)
  39. ;code
  40.  
  41. :code 2!
  42.     pop.l    a0
  43.     pop.l    (a0)+
  44.     pop.l    (a0)
  45. ;code
  46.  
  47. :code 2OVER
  48.     push.l    12(a6)
  49.     push.l    12(a6)
  50. ;code
  51.  
  52. :code 2SWAP
  53.     movem.l    (a6)+,d0-d3
  54.     push.l    d1
  55.     push.l    d0
  56.     push.l    d3
  57.     push.l    d2
  58. ;code
  59.  
  60.  
  61. \ Our : is immediate, and gives an error if not in execution state.
  62. \ ANSI : isn't immediate, and is legal within definitions.
  63.  
  64. : :        0 -> state
  65.         postpone :  ;
  66.  
  67. : CREATE    <builds  ;
  68.  
  69. : BASE        ['] base  ;        \ BASE is a variable, not a value
  70. : STATE        ['] state  ;    \ Likewise STATE
  71.  
  72.         
  73. \ ENVIRONMENT is the only CORE word that takes much implementing!
  74.  
  75. string+    ENV$
  76.  
  77. : (ENV)        \ ( -- false | x true )
  78.     " /CHAR"                search: env$  if  1    true    exit  then
  79.     " /COUNTED-STRING"        search: env$  if  255    true    exit  then
  80.     " /HOLD"                search: env$  if  30    true    exit  then
  81.     " /PAD"                    search: env$  if  200    true    exit  then
  82.     " /TIB"                    search: env$  if  400    true    exit  then
  83.     " ADDRESS-UNIT-BITS"    search: env$  if  8    true    exit  then
  84.     " ALIGN"                search: env$  if  2    true    exit  then
  85.     " CORE"                    search: env$  if  true    true    exit  then
  86.     " CORE-EXT"                search: env$  if  false    true    exit  then
  87.     " FULL"                    search: env$  if  true    true    exit  then
  88.     " ERROR-HANDLING"        search: env$  if  true    true    exit  then
  89.     " ERROR-HANDLING-EXT"    search: env$  if  true    true    exit  then
  90.     " MAX-CHAR"                search: env$  if  255    true    exit  then
  91.     " MAX-D"                search: env$  if  -1  big#    true    exit  then
  92.     " MAX-N"                search: env$  if  big#    true    exit  then
  93.     " MAX-U"                search: env$  if  -1    true    exit  then
  94.     " MAX-UD"                search: env$  if  -1 -1    true    exit  then
  95.      " RETURN-STACK-CELLS"    search: env$  if  RstkSpace 4/ true    exit  then
  96.     " STACK-CELLS"            search: env$  if  StkSpace  4/ true    exit  then
  97.  
  98.     ( none matched )  false  ;
  99.  
  100.  
  101. : ENVIRONMENT    \ ( addr len -- false | x true )
  102.     put: env$  false -> case?
  103.     (env)
  104.     release: env$  ;
  105.  
  106.  
  107. \ CORE EXT words:
  108.  
  109. :code 2>R
  110.     move.l    (a6)+,-(a7)
  111.     move.l    (a6)+,-(a7)
  112. ;code
  113.  
  114. :code 2R>
  115.     move.l    (a7)+,-(a6)
  116.     move.l    (a7)+,-(a6)
  117. ;code
  118.  
  119. :code 2R@
  120.     push.l    4(a7)
  121.     push.l    (a7)
  122. ;code
  123.  
  124.  
  125. : TO    postpone ->  ;                immediate
  126.  
  127. : [COMPILE]    postpone postpone  ;    immediate
  128.  
  129. : WITHIN        over - >r - r> u<  ;
  130.  
  131. false -> slctrs?            \ Disable selectors -- in ANSI, XXX: is a
  132.                             \ normal Forth word
  133.